perm filename MKVIC.FAI[1,BGB] blob
sn#015995 filedate 1972-12-06 generic text, type T, neo UTF8
00100 TITLE MKVIC - MAKE A VIDEO INTENSITY CONTOUR - AUGUST 1972.
00200 COMMENT/
00300
00400 MEMORY:
00500
00600 TVBUF 216 lines of 288 columns. 36 - 288 - 62,208.
00700 PAC 1728 words - 62208 bits. 18 - 144 - 31,104.
00800 HSEG 1729 words. 6 - 48 - 10,368.
00900 VSEG 1736 words. 4 - 32 - 6,912.
01000 1 - 8 - 1,728.
01100 PROCESS:
01200
01700 MKVICS make video intensity contours.
01800 MKVIC make a single contour.
01900
02000 THRESHOLD Generate 1-bit Image.
02100 PACXOR Rook's move exclusive OR'ing.
02200
02300 PIXPTR TV picture byte pointer.
02400 VICONT contrast of contours.
02500 ARCONT ARC segment Contrast.
02600
02700 MKARCS Make Arcs - width proportional to constrast.
02800
02900 FARCL Fit Arcs Linear.
03000 SPLARC Spline Arcs Fit.
03100
03200 /
03300
03400 ; ROW-COL FIXED POINT 0000.00 OPERATIONS.
03500 OPDEF FLO[FSC 225]
03600
03700 EXTERN GETBLK,KLPGON
00100 ;CONTROL FLAGS.
00200 INTERN FLGSIX,FLGARC,FLGBK
00300
00400 FLGSIX:-1 ;SIX BIT TELEVISON.
00500 FLGARC:-1 ;ENABLE MAKE ARC SMOOTHING.
00600 FLGBK:-1 ;ENABLE BABY KILLER.
00700 VCUT: 14 ;VERTEX CONTRAST THRESHOLD.
00800
00900 ;ARC WIDTH PROPORTIONAL TO CONTRAST TABLE FOR MKARCS.
01000 ARCWID:
01100 FOR I←0,5{1.0↔}
01150 FOR I←6,12{1.0↔}
01200 FOR I←13,17{1.0↔}
01300 FOR I←20,37{1.0↔}
01400 FOR I←40,77{0.7↔}
01500 0
00100 ;LINK NAMES.
00200
00300 RC←←-1
00400 DEFINE ROW(A,Q){CAR A,-1(Q)}↔DEFINE ROW.(A,Q){DIP A,-1(Q)}
00500 DEFINE COL(A,Q){CDR A,-1(Q)}↔DEFINE COL.(A,Q){DAP A,-1(Q)}
00600
00700 DEFINE CONT(A,Q){NIP A,0(Q)}↔DEFINE CONT.(A,Q){DIP A,0(Q)}
00800 DEFINE ARC(A,Q){CDR A,0(Q)} ↔ DEFINE ARC.(A,Q){DAP A,0(Q)}
00900
01000 DEFINE CW (A,Q){CAR A,1(Q)} ↔ DEFINE CCW (A,Q){CDR A,1(Q)}
01100 DEFINE CW.(A,Q){DIP A,1(Q)} ↔ DEFINE CCW.(A,Q){DAP A,1(Q)}
01200
01300 DEFINE PED(A,Q){CAR A,1(Q)}
01400 DEFINE PED.(A,Q){DIP A,1(Q)}
00100 INTERN HEADER,TVBUF
00200 HEADER: BLOCK =10
00300 TVBUF: BLOCK =10368
00400 PAC: BLOCK =1728
00500 VSEG: BLOCK =1729
00600 HSEG: BLOCK =1736
00700 ISAVED: 0
00800
00900 ;WINDOW FRAME POLYGON.
01000 INTERN PGON0
01100 PGON0: .+2
01200 BEGIN
01300 4↔ 0↔XWD W,0↔XWD .-2,.-2 ;PGON BLOCK.
01800
01900 0↔ W: 0↔ XWD N,S↔0
02000 =216B11↔ S: 0↔ XWD W,E↔0
02100 =216B11 + =288B29↔ E: 0↔ XWD S,N↔0
02200 =288B29↔ N: 0↔ XWD E,W↔0
02300
02400 BEND
00100 ;MAKE VIDEO INTENSITY CONTOURS.
00200 SUBR(MKVICS)
00300 BEGIN MKVICS
00400 LAC 1,ARG2↔DAC 1,Q0#
00500 LAC 1,ARG1↔ANDCMI 1,377↔DAC 1,Q1#
00600 SETZM LEVEL#
00700
00800 ;FIND AN INTENSITY CONTOUR ENABLE BIT OR EXIT.
00900 L0: LAC 0,Q0↔LAC 1,Q1
01000 L1: AOS 2,LEVEL↔LSHC 0,1↔JUMPL L2
01100 SKIPE 0↔GO L1↔SKIPE 1↔GO L1↔POP2J
01200 L2: DAC 0,Q0↔DAC 1,Q1
01300
01400 ;MAIN VIC CREATION SEQUENCE.
01500 PUSH P,LEVEL
01600 PUSHJ P,THRESH
01700 PUSHJ P,PACXOR
01800 L3: PUSHJ P,MKVIC ;Make a single contour loop.
01900 JUMPE 1,L0 ;no more contours at this level.
02000 DAC 1,P1#
02100 PUSH P,1
02200 PUSHJ P,VICONT ;VIC-CONTRAST.
02300
02400 ;THE BABY KILLER.
02500 ;Eliminate Insignificant Contours - small low contrast.
02600 SKIPN FLGBK↔GO .+8
02700 LAC 1,P1
02800 LACM -1(1)
02900 CAIL =10↔GO .+4
03000 PUSH P,P1↔PUSHJ P,KLPGON↔GO L3
03100
03200 ;Smooth VIC into a loop of ARC segments.
03300 LAC 1,P1↔SKIPN FLGARC↔GO L4 ;MAKE ARC ENABLED ?
03400 PUSHJ P,MKPAP ;Proto Arc Polygon.
03500 DAC 1,P2#
03600 PED 1,1↔DAC 1,V1#
03800 CCW 1,1↔DAC 1,V2#
03900 PUSH P,V1↔PUSH P,V2↔PUSHJ P,MKARCS
04000 PUSH P,V2↔PUSH P,V1↔PUSHJ P,MKARCS
04300 PUSH P,P1↔PUSHJ P,KLPGON
04350
04400 ;PUT P2 INTO THE PGON-RING.
04500 LAC 1,P2
04600 L4: LAC 2,PGON0 ↔ CAR 3,2(2)
04700 DIP 3,2(1)↔DAP 1,2(3)
04800 DAP 2,2(1)↔DIP 1,2(2)
04900 GO L3
05000 BEND
00100 ;MKVIC - MAKE A VIDEO INTENSITY CONTOUR - AUGUST 1972.
00200 ;PGON ← MKVIC;
00300 SUBR(MKVIC)
00400 BEGIN MKVIC
00500
00600 ACCUMULATORS{A2,A3,RC.,MASK,I,PTR,D,E,V}
00700 LAC I,ISAVED
00800 CDR PTR,ARG1
00900 SLACI I↔HRRI PAC↔DAC PACPTR#; PAC POINTER INDEXED BY I.
01000
01100 ;FIND THE ROW & COL OF THE UPPER LEFT MOST VSEG.
01200 L1: SKIPE 1,VSEG(I)↔GO L2
01300 AOS I↔CAIE I,=1728↔GO L1
01400 SETZ 1,↔POP0J;EMPTY.
01500
01600 L2: DAC I,ISAVED↔JFFO 1,.+1↔SLACI MASK,400000
01700 MOVNS 2↔LSH MASK,(2)↔MOVNS 2
01800 LAC RC.,I↔ANDI RC.,7↔IMULI RC.,=36↔ADD RC.,2 ;COLUMN.
01900 LAC I↔LSH -3↔DIP RC.↔LSH RC.,6 ;ROW.
02000
02100 ;DISTINGUISH BLOBS FROM HOLES.
02200 SETZM HOLE#
02300 TDNN MASK,@PACPTR ;HOLE OR BLOB ?
02400 SETOM HOLE# ;HOLE'A'COMING.
02500
02600 ;...AND HEAD SOUTH.
02700
02800 DAC RC.,RCMIN#
02900 SETZM RCMAX#
03000 SETZ V,↔SETZM ECNT#
03100 PUSHJ P,FOLLOW
03200 LAC V,V0
03300 CCW. V,E↔CW. E,V
03400
03500 ;MAKE & RETURN VIC POLYGON.
03600
03700 SETQ(PTR,{GETBLK})
03800 LAC 1,ECNT
03900 SKIPE HOLE#↔MOVNS 1 ;-CNT INDICATES A HOLE.
04000 DAC 1,-1(PTR)
04100 CCW E,V
04200 DIP E,1(PTR)
04300 LAC 1,PTR
04400 L3: POP0J
00100 ;THE SUB-OPERATIONS OF MKVIC.
00200
00300 DEFINE TRY (SEG,YES) {
00400 LAC SEG(I)↔TDZN MASK↔GO .+3↔DAC SEG(I)↔GO YES}
00500 DEFINE LEFT {SUBI RC.,100↔ROT MASK,1↔CAIN MASK,1↔SOS I}
00600 DEFINE RIGHT {ADDI RC.,100↔ROT MASK,-1↔SKIPG MASK↔AOS I}
00700 DEFINE UP {SUB RC.,[1B11]↔SUBI I,8}
00800 DEFINE DOWN {ADD RC.,[1B11]↔ADDI I,8}
00900 DEFINE DEL $ (A,B){LAC D,[XWD 0$A$30,0$B$30]}
01000
01100 ;CREATE NEW EDGE AND VERTEX OF A VIC.
01200 TURN: 0
01300 AOS TURNS#
01400 ADD D,RC.
01500 AOS 2,ECNT
01600
01700 ;VERTEX
01800 CALL GETBLK
01900 SKIPN V↔GO[DAC 1,V0#↔DAC 1,V↔GO T2]
02000 DAC 1,V
02200 CCW. V,E↔CW. E,V
02300 T2: DAC D,RC(V)
02400 CAMLE D,RCMAX
02500 GO[DAC D,RCMAX↔DAC V,V1#↔GO .+1]
02700 ;EDGE
02900 DAC V,E
03200 GO @TURN
00100 ;MAKE PROTO ARC POLYGON USING V0 AND V1.
00200 SUBR(MKPAP)
00300 AV1←MASK↔AV2←I
00400 CALL GETBLK↔DAC 1,PTR
00500 CALL GETBLK↔DAC 1,AV1
00600 CALL GETBLK↔DAC 1,AV2
00700 CCW. AV1,AV2↔CW. AV1,AV2
00800 CCW. AV2,AV1↔CW. AV2,AV1
00900 ;UPPER MOST LEFT.
01000 LAC 1,V0↔ARC. 1,AV1↔ARC. AV1,1
01100 LAC RC(1)↔DAC RC(AV1)
01200 ;LOWER MOST RIGHT.
01300 LAC 2,V1↔ARC. 2,AV2↔ARC. AV2,2
01400 LAC RC(2)↔DAC RC(AV2)
01500
01600 PED. AV1,PTR
01700 LAC 1,PTR
01800 POP0J
00100 ;THE ALCHEMIST OF MKVIC -
00200 ; - convert lead into golden line segments.
00300
00400 NORTH: ADD D,[1B11]↔JSR TURN
00500 NORTH2: LEFT↔DEL(+,-)↔ TRY HSEG,WEST
00600 RIGHT↔UP↔ TRY VSEG,NORTH2
00700 DOWN↔DEL(+,+)↔ TRY HSEG,EAST↔FATAL(NORTH)
00800 NORTH3: JSR TURN↔LEFT
00900 NORTH4: UP↔DEL(+,-)↔ TRY HSEG,WEST↔GO NORTH4
01000
01100
01200 WEST: ADDI D,100↔JSR TURN
01300 WEST2: CAMN RC.,RCMIN↔POPJ P,;TRY FOR E.O.VIC.
01400 FOLLOW: DEL(+,+)↔ TRY VSEG,SOUTH
01500 LEFT↔ TRY HSEG,WEST2
01600 RIGHT↔UP↔DEL(-,+)↔TRY VSEG,NORTH↔FATAL(WEST)
01700
01800
01900 SOUTH: JSR TURN
02000 SOUTH2: DOWN↔DEL(-,+)
02100 CAR RC.↔CAIN =216B29↔GO EAST3
02200 TRY HSEG, EAST
02300 TRY VSEG,SOUTH2
02400 LEFT↔DEL(-,-)↔ TRY HSEG,WEST↔ FATAL(SOUTH)
02500
02600
02700 EAST: JSR TURN
02800 EAST2: RIGHT↔DEL(-,-)
02900 CDR RC.↔CAIN =288B29↔GO NORTH3
03000 UP↔ TRY VSEG,NORTH
03100 DOWN↔ TRY HSEG,EAST2
03200 DEL(+,-)↔ TRY VSEG,SOUTH↔FATAL(EAST)
03300 EAST3: JSR TURN↔UP
03400 EAST4: RIGHT↔DEL(-,-)
03500 CDR RC.↔CAIN =288B29↔GO[DOWN↔GO NORTH3]
03600 TRY VSEG,NORTH↔GO EAST4
03700 BEND
00100 ;PACXOR - Do rook's exclusive OR'ing.
00200 SUBR(PACXOR)
00300 BEGIN PACXOR
00400 I←2
00500 SLACI PAC↔LAPI HSEG↔BLT HSEG+=1727
00600 SLACI PAC↔LAPI VSEG↔BLT VSEG+=1727
00700 SETZ I,
00800 HRRI PAC↔DAP L+2
00900 L: TRNN I,7↔SETZ 1,↔LAC PAC(I)
01000 XORM HSEG+8(I) ; HSEG bits are above PAC bits.
01100 ROTC -1↔ROT 1,1
01200 XORM VSEG(I) ; VSEG are left of PAC bits.
01300 AOS I
01400 CAIE I,=1728
01500 GO L
01600 SETZM ISAVED
01700 POP0J
01800 BEND
00100 ;THRESHOLD(CUT) - pre-Foonly Version.
00200 SUBR(THRESH)
00300 BEGIN THRESH
00400 I←13 ↔ J←14 ↔ PTR←15
00500 LAC [XWD L,2]↔BLT 11
00600 LAP 4,ARG1↔SLACI I,-=1728
00700 HRLZI PTR,440600 ; =36 BITS TO GO, 6 BITS PER BYTE.
00800 SKIPN FLGSIX↔ HRLZI PTR,440400 ; 4 BITS PER BYTE.
00900 HRRI PTR,TVBUF
01000 HRRI 7,PAC↔GO 2
01100
01200 ;ACCUMULATOR LOOP.
01300 L: MOVEI J,=36 ;2
01400 ILDB PTR ;3
01500 SUBI ;CUT ;4
01600 ROTC 1 ;5
01700 SOJG J,3 ;6
01800 SETCAM 1,PAC(I) ;7
01900 AOBJN I,2 ;10
02000 POP1J ;11
02100 BEND
02200
02300 SUBR(HISTOGRAM)
02400 BEGIN HISTOGRAM
02500 EXTERN HISTO,DPYHIS
02600 PTR←15
02700
02800 LAC 1,HISTO↔SETZM(1) ;CLEAR HISTOGRAM.
02900 HRLZ 1↔ADDI 1(1)↔BLT =65(1)
03000
03100 LAC[XWD L,2]↔BLT 5
03200
03300 HRLZI PTR,440600↔SKIPN FLGSIX
03400 HRLZI PTR,440400↔HRRI PTR,TVBUF
03500 MOVEI =62208 ;NUMBER OF PIXELS IN A PICTURE.
03600 ADD 3,HISTO ;HISTOGRAM POINTER.
03700 JRST 2
03800
03900 ;ACCUMULATOR LOOP.
04000 L: ILDB 1,PTR ;2
04100 AOS 1(1) ;3
04200 SOJG 2 ;4
04300 GO .+1 ;5
04400
04500 CALL(DPYHIS)
04600 POP0J
04700 BEND
00100 ;PTR ← PIXPTR(ROW,COL) - COMPUTE PICTURE BYTE POINTER.
00200 SUBR(PIXPTR)
00300 BEGIN PIXPTR
00400 ;AC-0 PC return address for JSP entry.
00500 ;AC-1 Row argument, byte pointer value.
00600 ;AC-2 Column argument.
00700 ;AC-3 get clobbered.
00800 SETZ↔LAC 1,ARG2↔LAC 2,ARG1
00900 ;PIXPTR+3:
01000 SKIPN FLGSIX↔JRST L
01100 ;SIX BIT BYTES - TVBUF + ROW*48 + (COL DIV 6).
01200 IMULI 1,=48
01300 ADDI 1,TVBUF
01400 IDIVI 2,6
01500 ADD 1,2
01600 HLL 1,[POINT 6,0,-1 ↔ POINT 6,0,05 ↔ POINT 6,0,11
01700 POINT 6,0,17 ↔ POINT 6,0,23 ↔ POINT 6,0,29](3)
01800 JUMPN@↔POP2J
01900 ;FOUR BIT BYTES - TVBUF + ROW*32 + (COL DIV 9).
02000 L: ASH 1,5
02100 ADDI 1,TVBUF
02200 IDIVI 2,9
02300 ADD 1,2
02400 HLL 1,[POINT 4,0,-1 ↔ POINT 4,0,03 ↔ POINT 4,0,07
02500 POINT 4,0,11 ↔ POINT 4,0,15 ↔ POINT 4,0,19
02600 POINT 4,0,23 ↔ POINT 4,0,27 ↔ POINT 4,0,31]
02700 JUMPN@↔POP2J
02800 BEND
00100 ;VICONTRAST(PGON) - HORIZONTAL/VERTICAL CONTRAST.
00200 SUBR(VICONT)
00300 BEGIN VICONT
00400 R←1 ↔ C←2 ↔ R2←10 ↔ C2←11 ↔ E←13 ↔ V1←14 ↔ V2←15
00500
00600 ;INITIALIZATION - SETUP FIRST EDGE OF THE PGON.
00700
00800 LAC E,ARG1 ↔ PED E,E
00900 DAC E,E0# ↔ LAC V2,E
01000 LAC RC(V2)↔ADD [XWD 30,30]
01100 CAR R2,↔LSH R2,-6
01200 CDR C2,↔LSH C2,-6
01300
01400 ;ADVANCE CCW ALONG PGON.
01500
01600 L0: DAC V2,V1 ↔ DAC R2,R1# ↔ DAC C2,C1# ↔ CCW V2,E
01700 LAC RC(V2)↔ADD [XWD 30,30]
01800 CAR R2,↔LSH R2,-6 ↔ CDR C2,↔LSH C2,-6
01900
02000 ;SELECT HORIZONTAL OR VERTICAL.
02100
02200 CAMN R2,R1 ↔ JRST HORZNT
02300 CAMN C2,C1 ↔ JRST VERTCL
02400 OUTSTR[ASCIZ/VICONT ¬HV./]
02500 L1: LAC E,V2↔CAME E,E0↔JRST L0
02600 POP1J
00100 ;HORIZONTAL CASE LEFT TO RIGHT.
00200 HORZNT:
00300 LAC R,R1
00400 LAC C,C1 ↔ LAC 5,C2
00500 CAML C,C2 ↔ EXCH C,5 ;GET FAR LEFT IN C.
00600 LAC 6,C ↔ SUB 5,C ;COLUMN DIFFERENCE.
00700
00800 ;SETUP TVBUF BYTE POINTERS 1 INSIDE, 3 OUTSIDE.
00900 JSP PIXPTR+3↔LAC 3,1
01000 SUBI 1,=32 ↔ SKIPE FLGSIX ↔ SUBI 1,=16
01100 CAME 6,C1 ↔ EXCH 1,3 ↔ LAC 6,5
01200
01300 ;ACCUMULATE INTENSITIES ALONG THE EDGE.
01400 SETZB 2,4↔ILDB 1↔ADDM 2↔ILDB 3↔ADDM 4↔ SOJG 5,.-4
01500
01600 ;SET ABOVE THE TOP OR BELOW THE BOTTOM TO UTTER DARKNESS.
01700 SKIPE R2↔CAIN R2,=216↔SETZ 4,
01800
01900 ;COMPUTE AND SAVE AVERAGE INTENSITIES AND CONTRAST.
02000 IDIV 2,6;DIP 2,2(E) ;INSIDE CCW V1 TO V2.
02100 IDIV 4,6;DAP 4,2(E) ;OUTSIDE CW V1 TO V2.
02200 SUB 2,4↔CONT. 2,E ;CONTRAST INSIDE MINUS OUTSIDE.
02300 JRST L1
02400
02500 ;VERTICAL CASE TOP TO BOTTOM.
02600 VERTCL:
02700 LAC C,C1 ↔ LAC R,R1 ↔ LAC 5,R2
02800 CAML R,R2 ↔ EXCH R,5 ;GET UPPERMOST ROW.
02900 LAC 6,R ↔ SUB 5,R ;ROW DIFFERENCE.
03000
03100 ;SETUP TVBUF BYTE POINTERS 1 INSIDE, 3 OUTSIDE.
03200 JSP PIXPTR+3↔TLO 1,7↔LAC 3,1 ;INDEXED BY AC-7.
03300 IBP 1 ↔ TLC 3,(44B5) ;FLIP 'EM.
03400 TLNN 3,(44B5)↔SOSA 3 ;DECREM BYTE POINTER.
03500 TLC 3,(44B5) ;STATUS QUO ANTE.
03600 CAME 6,R1 ↔ EXCH 1,3 ↔ LAC 6,5
03700
03800 ;ACCUMULATE INTENSITIES ALONG THE EDGE.
03900 SETZB 2,4↔SETZ 7,
04000 MOVEI =32↔SKIPE FLGSIX↔MOVEI =48↔DAP .+5 ;ROW WORD WIDTH.
04100 LDB 1↔ADDM 2↔LDB 3↔ADDM 4↔ADDI 7,0↔ SOJG 5,.-5
04200
04300 ;SET BEYOND THE LEFT OR RIGHT TO UTTER DARKNESS.
04400 SKIPE C2↔CAIN C2,=288↔SETZ 4,
04500
04600 ;COMPUTE AND SAVE AVERAGE INTENSITIES AND CONTRAST.
04700 IDIV 2,6;DIP 2,2(E) ;INSIDE CCW V1 TO V2.
04800 IDIV 4,6;DAP 4,2(E) ;OUTSIDE CW V1 TO V2.
04900 SUB 2,4↔CONT. 2,E ;CONTRAST INSIDE MINUS OUTSIDE.
05000 JRST L1
05050 LIT↔VAR
05100 BEND
00100 ; ARC CONTRAST.
00200 SUBR(ARCONT)
00300 BEGIN ARCONT
00400 ACCUMULATORS{U1,U2,V1,V2,E,E0,N}
00500
00600 LAC E,ARG1 ;FIRST EDGE OF AN ARC PGON.
00700 CAR E,1(E)
00800 DAC E,E0
00900 CW V2,E
01000
01100 L1: LAC V1,V2↔CCW V2,E
01200 ARC U1,V1↔ARC U2,V2
01300
01400 SETZ↔MOVEI N,1
01500
01600 CCW U1,U1↔ADD 2(U1)↔CCW U1,U1
01700 CAME U1,U2↔AOJA N,.-4
01800
01900 CAR 2,0 ↔ IDIV 2,N ↔ DIP 2,2(E)
02000 CDR 0,0 ↔ IDIV 0,N ↔ DAP 0,2(E)
02100 SUB 2,0 ↔ DAP 2,-1(E)
02200
02300 CCW E,V2↔CAME E,E0↔JRST L1
02400
02500 ;VERTEX CONTRAST.
02600 L2: NAP 0,-1(E)↔CCW V1,E
02700 CCW E,V1↔NAP 1,-1(E)
02800 SUB 1,0↔DAP 1,2(V1)
02900
03000 NAP 1,-1(E)↔MOVMS↔MOVMS 1
03100 CAMG 0,1↔EXCH 0,1
03200 SETO 2,↔CAML 0,VCUT↔CAML 1,VCUT↔SETZ 2,
03300 DIP 2,2(V1) ;MARK TRANSITIONAL VERTEX.
03400
03500 CAME E,E0↔JRST L2↔POP1J
03600 BEND
00100 ;SUBR MKARCS (ARCV1,ARCV2) - FROM U1 CCW TO U2.
00200 SUBR(MKARCS)
00300 BEGIN MKARCS
00400 EXTERN SQRT; CLOBBERS AC1 THRU AC4.
00500 ACCUMULATORS{D,U1,U2,V1,V2,A,B,C,U,V}
00600 LAC V1,ARG2↔LAC V2,ARG1↔SETZM AVCNT#
00700
00800 ;CHECK FOR TRIVAIL CASE.
00900 L0: ARC U1,V1↔ARC U2,V2
01000 CCW 0,U1↔CAMN 0,U2↔GO L3
01100
01200 ;COMPUTE NORMALIZED ARC EDGE COEFFICIENTS.
01300 ROW A,V1↔FLO A, ; A ← Y1.
01400 COL B,V2↔FLO B, ; B ← X2.
01500 COL C,V1↔FLO C, ; C ← X1.
01600 ROW D,V2↔FLO D, ; D ← Y2.
01700 LAC 1,B↔FMPR 1,A ; 1 ← X2*Y1.
01800 FSBR A,D↔FSBR B,C ; A ← Y1-Y2. B ← X2-X1.
01900 FMPR C,D↔FSBR C,1 ; C ← X1*Y2 - X2*Y1.
02000 LAC 0,A↔FMPR 0,0↔LAC 1,B↔FMPR 1,1↔FADR 1,0
02100 CALL SQRT,1↔FDVR A,1↔FDVR B,1↔FDVR C,1
02200
00100 ;SET 'EM UP FOR AN ARC PASS.
00200 ARC U1,V1↔ARC U2,V2
00300 SETZM DMAX#↔SETZM DMIN#
00400 SETZM VMAX#↔SETZM VMIN#
00500 SETZM MAXCON#
00600 ;GO FROM U1 CCW TO U2 AND FIND THE U FURTHEST OFF THE ARC-EDGE.
00700 L1: CCW U1,U1↔CAMN U1,U2↔GO L2
00800 COL 0,U1↔FLO 0,↔ROW 1,U1↔FLO 1,
00900 FMPR 0,A↔FMPR 1,B↔LAC D,C↔FADR D,0↔FADR D,1
01000 CAMGE D,DMIN↔GO [DAC U1,VMIN↔DAC D,DMIN↔GO .+1]
01100 CAMLE D,DMAX↔GO [DAC U1,VMAX↔DAC D,DMAX↔GO .+1]
01200 ;KEEP TRACK OF MAXIMUM EDGE CONTRAST ALONG ARC.
01300 CONT 0,V1↔MOVM↔CAMLE MAXCON↔DAC MAXCON↔GO L1
01400
01500 ;WHEN EXTREMA EXCEED ARCWID[MAXCON] THEN FORM ARC-POINTS.
01600 L2: LAC U,VMIN↔LACM DMIN
01700 CAMGE DMAX↔LAC U,VMAX
01750 CAMGE DMAX↔LAC DMAX
01800 LAC 1,MAXCON↔CAMGE ARCWID(1)↔GO L3
01900
02000 ;OLDE ESPLIT: →CW→ V2...D...AV...E...V1 ←CCW←
02200 CALL GETBLK↔DAC 1,V↔AOS AVCNT
02300 ARC. U,V↔ARC. V,U
02350 LAC RC(U)↔DAC RC(V)
02400 CCW. V,V1↔CW. V1,V
02500 CCW. V2,V↔CW. V,V2
02700 LAC V2,V↔GO L0
02800
02900 ;ADVANCE CCW AN ARC-EDGE OR EXIT.
03000 L3: CAMN V2,ARG1↔POP2J
03100 LAC V1,V2↔CCW V2,V2
03150 GO L0
03200 BEND
00100 ;FARCL(PGON) - FIT ARCS LINEAR.
00200 SUBR(FARCL)
00300 BEGIN FARCL
00400 X←1
00500 ACCUMULATORS{Y,SX,SY,XX,YY,XY,N,E,U1,U2,V1,V2}
00600 DAC 12,AC12
00700
00800 ;Clear the Locus of all the Arc Vertices.
00900 LAC E,ARG1↔CAR E,1(E)↔DAC E,E0#
01000 CCW V1,E ↔ SETZM -1(V1)
01100 CCW E,V1 ↔ CAME E,E0↔JRST .-4
01200
01300 ;Advance along Polygon.
01400 CW V2,E
01500 L1: LAC V1,V2↔CCW V2,E
01600 ARC U1,V1↔ARC U2,V2
01700 CW U1,U1↔CW U1,U1
01800 CW U1,U1↔CW U1,U1
01900 CW U1,U1↔CW U1,U1
02000 CCW U2,U2↔CCW U2,U2
02100 CCW U2,U2↔CCW U2,U2
02200 CCW U2,U2↔CCW U2,U2
02300
02400 ;Arc Scan Initialization.
02500 LAC [XWD SX,SY]↔SETZ SX,↔BLT N↔JRST .+3
02600 ;Advance along VIC within the ARC.
02700 L2: CCW U1,U1↔CCW U1,U1
02800 ;Accumulate a Point.
02900 CDR X,-1(U1)↔FLO X,↔CAR Y,-1(U1)↔FLO Y,
03000 FAD SX,X ↔ FAD SY,Y
03100 LAC X ↔ FMP Y ↔ FAD XY,0
03200 FMP X,X ↔ FAD XX,X
03300 FMP Y,Y ↔ FAD YY,Y
03400 CAME U1,U2↔AOJA N,L2↔AOS N
00100 ;Compute symetric least squares line coefficients.
00200 ; Q ← N*XY - SY*SX.
00300 ; A ← Q + SY*SY - N*YY.
00400 ; B ← Q + SX*SX - N*XX.
00500 ; C ← SX*YY + SY*XX - XY*(SX+SY).
00600
00700 L3: LAC 2,SX↔FMP 2,YY
00800 LAC 0,SY↔FMP 0,XX↔FAD 2,0
00900 LAC SX↔FAD SY↔FMP XY↔FSB 2,0↔DAC 2,CCCC#
01000
01100 FSC N,233↔FMP XX,N↔FMP XY,N↔FMP YY,N ;all the N terms.
01200 LAC SX↔FMP SY↔FSB XY,0 ;Q in XY.
01300
01400 FMP SY,SY↔FAD SY,XY↔FSB SY,YY↔DAC SY,AAAA#
01500 FMP SX,SX↔FAD SX,XY↔FSB SX,XX↔DAC SX,BBBB#
01600
01700 FMP SY,SY↔FMP SX,SX↔FAD SX,SY
01800 SLACI(1.0)↔FDVR SX↔DAC QQQQ# ;PSEUDO NORMALIZATION.
01900
02000 ;Solve for the Locii where perpendiculars dropped from
02100 ;the arc-edge hit the fitted line.
02200 ; Q ← 1/(A*A + B*B).
02300 ; D ← (B*X1 - A*Y1).
02400 ; X ← (B*D - A*C)*Q.
02500 ; Y ←-(A*D + B*C)*Q.
02600
02700 L4: ARC U1,V1
02800 CDR X,-1(U1)↔FLO X,↔CAR Y,-1(U1)↔FLO Y,
02900 FMP X,BBBB↔FMP Y,AAAA↔FSBR X,Y↔LACN Y,X ;DDDD.
03000 FMP X,BBBB↔FMP Y,AAAA
03100 LAC AAAA↔FMP CCCC↔FSBR X,↔FMPR X,QQQQ↔247040226000;FIX
03200 LAC BBBB↔FMP CCCC↔FSBR Y,↔FMPR Y,QQQQ↔247100226000
03300 DIP Y,X↔ADDM X,-1(V1)
03400
03500 ARC U2,V2
03600 CDR X,-1(U2)↔FLO X,↔CAR Y,-1(U2)↔FLO Y,
03700 FMP X,BBBB↔FMP Y,AAAA↔FSBR X,Y↔LACN Y,X ;DDDD.
03800 FMP X,BBBB↔FMP Y,AAAA
03900 LAC AAAA↔FMP CCCC↔FSBR X,↔FMPR X,QQQQ↔247040226000;FIX
04000 LAC BBBB↔FMP CCCC↔FSBR Y,↔FMPR Y,QQQQ↔247100226000
04100 DIP Y,X↔ADDM X,-1(V2)
04200
04300 CCW E,V2↔CAME E,E0↔JRST L1
04400 LAC 12,AC12↔POP1J
04500 BEND
04600 END